Datos de observaciones actuales

ruta_totales <- "C:\\Users\\Usuario\\Downloads\\ARCHIVOS DE POSIT\\TOTALES_2025.xlsx"
#"/cloud/project/TOTALES_2025.xlsx"
excel_sheets(ruta_totales)
## [1] "Plan1"
Totales2025 <- as.data.frame(read_xlsx(ruta_totales, sheet = "Plan1"))

Totales2025$Semana <- format(Totales2025$Fecha, format ="%Y-%U")

Fecha2025 <- Totales2025$Fecha

Totales2025 <- Totales2025 %>% 
  group_by(Semana = as.character(Semana)) %>% 
  summarize(Totales = sum(Totales), 
            .groups = "keep")
head(Totales2025)
## # A tibble: 6 × 2
## # Groups:   Semana [6]
##   Semana  Totales
##   <chr>     <dbl>
## 1 2024-48   2926.
## 2 2025-00   2466.
## 3 2025-01 204571.
## 4 2025-02 278470.
## 5 2025-03  82224.
## 6 2025-04  40008.
tail(Totales2025)
## # A tibble: 6 × 2
## # Groups:   Semana [6]
##   Semana  Totales
##   <chr>     <dbl>
## 1 2025-08 125620.
## 2 2025-09 363558.
## 3 2025-11  43291.
## 4 2025-13 412042.
## 5 2025-14   4749.
## 6 2025-15    923.
nrow(Totales2025)
## [1] 15

Series semanal

totales_2025_ts <- ts(Totales2025$Totales,start =1, frequency =1)
totales_2025_xts <- as.xts(totales_2025_ts)

Gráfica de las serie

Datos historicos de productos y servicios

ruta <- "C:\\Users\\Usuario\\Downloads\\ARCHIVOS DE POSIT\\Ventas_Suministros_Totales.xlsx"
excel_sheets(ruta)
## [1] "Ventas Totales Original"    "Servicios Totales Original"
# "Ventas Totales Original"    "Servicios Totales Original"

Productos y servicios

Productos_Totales <- as.data.frame(read_xlsx(ruta, 
                                             sheet = "Ventas Totales Original"))
Productos_Totales$Semana <- format(Productos_Totales$Fecha, format = "%Y-%U")
Productos_Totales$mes <- format(Productos_Totales$Fecha, format = "%Y-%m")
head(Productos_Totales)
##   Folio               Fecha           RFC                       Empresa
## 1     1 2019-07-01 10:01:03 VEPS740807T84 Silvia Elena Velasco Palacios
## 2     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 3     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 4     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 5     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 6     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
##   Cantidad            Unidad
## 1        1 Bidón de plástico
## 2        1             Pieza
## 3        1             Pieza
## 4        1             Pieza
## 5        1             Pieza
## 6        1             Pieza
##                                                  Descripcion ValorUnitario
## 1 Algicin marca Spin en presentación de garrafa de 20 Litros        700.00
## 2                Kit de Sello y espaciadores Piston Superior        308.04
## 3                Kit de sello y espaciadores Piston Inferior        811.78
## 4                              Kit Piston Superior 9000/9100        968.58
## 5                              Kit Piston Inferior 9000/9100       1784.38
## 6                               Engrane motriz Inferior 9100       1092.00
##       Total  Semana     mes
## 1  812.0000 2019-26 2019-07
## 2  357.3264 2019-26 2019-07
## 3  941.6648 2019-26 2019-07
## 4 1123.5528 2019-26 2019-07
## 5 2069.8808 2019-26 2019-07
## 6 1266.7200 2019-26 2019-07
nrow(Productos_Totales)
## [1] 1995
productos <- data.frame(Fecha = Productos_Totales$Fecha, Totales = Productos_Totales$Total)

Servicios_Totales <- as.data.frame(read_xlsx(ruta, 
                                             sheet = "Ventas Totales Original"))

Servicios_Totales$Semana <- format(Servicios_Totales$Fecha, format = "%Y-%U")
Servicios_Totales$mes <- format(Servicios_Totales$Fecha, format = "%Y-%m")
head(Servicios_Totales)
##   Folio               Fecha           RFC                       Empresa
## 1     1 2019-07-01 10:01:03 VEPS740807T84 Silvia Elena Velasco Palacios
## 2     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 3     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 4     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 5     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 6     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
##   Cantidad            Unidad
## 1        1 Bidón de plástico
## 2        1             Pieza
## 3        1             Pieza
## 4        1             Pieza
## 5        1             Pieza
## 6        1             Pieza
##                                                  Descripcion ValorUnitario
## 1 Algicin marca Spin en presentación de garrafa de 20 Litros        700.00
## 2                Kit de Sello y espaciadores Piston Superior        308.04
## 3                Kit de sello y espaciadores Piston Inferior        811.78
## 4                              Kit Piston Superior 9000/9100        968.58
## 5                              Kit Piston Inferior 9000/9100       1784.38
## 6                               Engrane motriz Inferior 9100       1092.00
##       Total  Semana     mes
## 1  812.0000 2019-26 2019-07
## 2  357.3264 2019-26 2019-07
## 3  941.6648 2019-26 2019-07
## 4 1123.5528 2019-26 2019-07
## 5 2069.8808 2019-26 2019-07
## 6 1266.7200 2019-26 2019-07
nrow(Servicios_Totales)
## [1] 1995
servicios <- data.frame(Fecha = Servicios_Totales$Fecha, Totales = Servicios_Totales$Total)

Totales <- merge(x = productos, servicios, all = T)

Totales$Semana <- format(Totales$Fecha, format = "%Y-%U")

Totales2019 <- Totales %>% 
  group_by(Semana = as.character(Semana)) %>% 
  summarize(Totales = sum(Totales), 
            .groups = "keep")
head(Totales2019)
## # A tibble: 6 × 2
## # Groups:   Semana [6]
##   Semana  Totales
##   <chr>     <dbl>
## 1 2019-26  55401.
## 2 2019-27  27527.
## 3 2019-28  16138.
## 4 2019-29  48245.
## 5 2019-30   7175.
## 6 2019-31  31157.
tail(Totales2019)
## # A tibble: 6 × 2
## # Groups:   Semana [6]
##   Semana  Totales
##   <chr>     <dbl>
## 1 2024-20  27773.
## 2 2024-22  30244.
## 3 2024-24  44905.
## 4 2024-25   6206 
## 5 2024-27   4988 
## 6 2024-29   3828
nrow(Totales2019)
## [1] 242

Serie historicos por mes

Totales2019_ts <- ts(Totales2019$Totales, start = 1, frequency = 1)

Gráfica por dia

Transformación

LAMT <- boxcox(x = as.numeric(Totales2019_ts), objective.name = "Log-Likelihood", optimize = T)
LAMT$lambda
## [1] 0.1723989
# [1] 0.1723989
Totales2019Semana <- boxcoxTransform(x = as.numeric(Totales2019_ts), lambda = LAMT$lambda )
head(Totales2019Semana)
## [1] 32.32742 27.99620 25.02391 31.42908 21.00369 28.72566
tail(Totales2019Semana)
## [1] 28.04819 28.54908 30.97142 20.34169 19.37533 18.25231
length(Totales2019Semana)
## [1] 242

Serie semanal con boxcox

serie_sem_tot <- ts(Totales2019Semana, start = 1, frequency = 1)
# entrenamiento

Grafica semanal

ACF y PACF

ggAcf(serie_sem_tot, lag.max = 52, col = "red", lwd = 2)

ggPacf(serie_sem_tot, lag.max = 52, col = "blue", lwd = 2)

Modelo

spec_sem_GARCH_11 <- ugarchspec(variance.model = list(model = "sGARCH", 
                                                      garchOrder = c(1, 1)),
                                mean.model = list(armaOrder = c(32, 29)), 
                                distribution.model = "std") 
aju_GARCH_11 <- ugarchfit(data = serie_sem_tot, 
                          spec = spec_sem_GARCH_11)
## Warning in arima(data, order = c(modelinc[2], 0, modelinc[3]), include.mean =
## modelinc[1], : possible convergence problem: optim gave code = 1
spec_sem_GARCH_21 <- ugarchspec(variance.model = list(model = "sGARCH", 
                                                      garchOrder = c(2, 1)),
                                mean.model = list(armaOrder = c(32, 29)), 
                                distribution.model = "std") 
aju_GARCH_21 <- ugarchfit(data = serie_sem_tot, 
                          spec = spec_sem_GARCH_21)
## Warning in arima(data, order = c(modelinc[2], 0, modelinc[3]), include.mean =
## modelinc[1], : possible convergence problem: optim gave code = 1
spec_sem_GARCH_12 <- ugarchspec(variance.model = list(model = "sGARCH", 
                                                      garchOrder = c(1, 2)),
                                mean.model = list(armaOrder = c(32, 29)), 
                                distribution.model = "std") 
aju_GARCH_12 <- ugarchfit(data = serie_sem_tot, 
                          spec = spec_sem_GARCH_12)
## Warning in arima(data, order = c(modelinc[2], 0, modelinc[3]), include.mean =
## modelinc[1], : possible convergence problem: optim gave code = 1
spec_sem_GARCH_22 <- ugarchspec(variance.model = list(model = "sGARCH", 
                                                      garchOrder = c(2, 2)),
                                mean.model = list(armaOrder = c(32, 29)), 
                                distribution.model = "std") 
aju_GARCH_22 <- ugarchfit(data = serie_sem_tot, 
                          spec = spec_sem_GARCH_22)
## Warning in arima(data, order = c(modelinc[2], 0, modelinc[3]), include.mean =
## modelinc[1], : possible convergence problem: optim gave code = 1

Comparando modelos usando AIC

infocriteria(aju_GARCH_11)
##                      
## Akaike       6.682725
## Bayes        7.634253
## Shibata      6.572588
## Hannan-Quinn 7.066035
infocriteria(aju_GARCH_21)
##                      
## Akaike       6.641553
## Bayes        7.607498
## Shibata      6.528485
## Hannan-Quinn 7.030670
infocriteria(aju_GARCH_12)
##                      
## Akaike       6.686557
## Bayes        7.652503
## Shibata      6.573489
## Hannan-Quinn 7.075675
infocriteria(aju_GARCH_22)
##                      
## Akaike       6.634561
## Bayes        7.614924
## Shibata      6.518534
## Hannan-Quinn 7.029487

Pronóstico

Con el conjunto de prueba de los totales diarios se realiza los pronósticos.

pronostico_garch22 <- ugarchforecast(fitORspec = aju_GARCH_22, 
                                     n.ahead = length(totales_2025_ts))

Volatilidad pronosticada

volatilidad_pronosticada <- pronostico_garch22@forecast$sigmaFor

Serie pronosticada.

serie_pronosticada <- pronostico_garch22@forecast$seriesFor
length(serie_pronosticada)
## [1] 15

Gráfica del pronóstico.

Intervalo de confianza

residuales <- residuals(aju_GARCH_22)
# objeto xts

residuales_df <- data.frame(Residuales = coredata(residuales))

head(residuales_df)
##   Residuales
## 1   2.052286
## 2  -2.278933
## 3  -5.251220
## 4   1.153946
## 5  -9.271447
## 6  -1.549471
errores_semana <- residuales_df
sd_errores_semana <- sd(errores_semana$Residuales, na.rm =T)
margen_erro_semana <- sd_errores_semana * qnorm(0.9)# 90%
margen_erro_semana2 <- sd_errores_semana * qnorm(0.975)# 95%

Limites

prediccion <- data.frame(pronosticos = as.numeric(pronostico_garch22@forecast$seriesFor), 
                        actuales = as.numeric(totales_2025_ts))
prediccion$inf <- prediccion$pronosticos - margen_erro_semana
prediccion$sup <- prediccion$pronosticos + margen_erro_semana
prediccion$inferior <- prediccion$pronosticos - margen_erro_semana2
prediccion$superior <- prediccion$pronosticos + margen_erro_semana2
head(prediccion)
##   pronosticos  actuales      inf      sup inferior superior
## 1    23.16797   2925.52 15.19249 31.14345 10.97052 35.36541
## 2    32.24078   2466.16 24.26530 40.21626 20.04333 44.43823
## 3    30.94365 204571.37 22.96817 38.91914 18.74621 43.14110
## 4    32.82931 278469.60 24.85383 40.80479 20.63186 45.02675
## 5    23.41481  82223.67 15.43933 31.39029 11.21736 35.61225
## 6    37.19336  40008.40 29.21788 45.16884 24.99591 49.39080
tail(prediccion)
##    pronosticos  actuales      inf      sup inferior superior
## 10    39.28439 125620.09 31.30891 47.25987 27.08694 51.48183
## 11    29.61150 363557.63 21.63602 37.58699 17.41406 41.80895
## 12    29.15349  43291.20 21.17801 37.12897 16.95604 41.35093
## 13    40.73056 412041.51 32.75508 48.70604 28.53312 52.92801
## 14    27.14545   4749.04 19.16997 35.12093 14.94800 39.34289
## 15    28.55654    923.36 20.58106 36.53202 16.35910 40.75399
nrow(prediccion)
## [1] 15
prediccion
##    pronosticos  actuales      inf      sup inferior superior
## 1     23.16797   2925.52 15.19249 31.14345 10.97052 35.36541
## 2     32.24078   2466.16 24.26530 40.21626 20.04333 44.43823
## 3     30.94365 204571.37 22.96817 38.91914 18.74621 43.14110
## 4     32.82931 278469.60 24.85383 40.80479 20.63186 45.02675
## 5     23.41481  82223.67 15.43933 31.39029 11.21736 35.61225
## 6     37.19336  40008.40 29.21788 45.16884 24.99591 49.39080
## 7     42.55636  97084.26 34.58088 50.53184 30.35892 54.75381
## 8     42.49367 418748.40 34.51819 50.46915 30.29622 54.69111
## 9     34.87741 380503.13 26.90193 42.85289 22.67997 47.07486
## 10    39.28439 125620.09 31.30891 47.25987 27.08694 51.48183
## 11    29.61150 363557.63 21.63602 37.58699 17.41406 41.80895
## 12    29.15349  43291.20 21.17801 37.12897 16.95604 41.35093
## 13    40.73056 412041.51 32.75508 48.70604 28.53312 52.92801
## 14    27.14545   4749.04 19.16997 35.12093 14.94800 39.34289
## 15    28.55654    923.36 20.58106 36.53202 16.35910 40.75399

Transformacion de valores 2025

actuales_trans <- boxcoxTransform(x = as.numeric(totales_2025_ts), lambda = 0.1723989)
actuales_trans
##  [1] 17.16284 16.49649 41.95785 44.56570 35.01316 30.24668 36.19903 48.23561
##  [9] 47.35071 38.10690 46.93490 30.74010 48.08540 19.16316 13.02265
prediccion$actuales_trans <- actuales_trans
prediccion
##    pronosticos  actuales      inf      sup inferior superior actuales_trans
## 1     23.16797   2925.52 15.19249 31.14345 10.97052 35.36541       17.16284
## 2     32.24078   2466.16 24.26530 40.21626 20.04333 44.43823       16.49649
## 3     30.94365 204571.37 22.96817 38.91914 18.74621 43.14110       41.95785
## 4     32.82931 278469.60 24.85383 40.80479 20.63186 45.02675       44.56570
## 5     23.41481  82223.67 15.43933 31.39029 11.21736 35.61225       35.01316
## 6     37.19336  40008.40 29.21788 45.16884 24.99591 49.39080       30.24668
## 7     42.55636  97084.26 34.58088 50.53184 30.35892 54.75381       36.19903
## 8     42.49367 418748.40 34.51819 50.46915 30.29622 54.69111       48.23561
## 9     34.87741 380503.13 26.90193 42.85289 22.67997 47.07486       47.35071
## 10    39.28439 125620.09 31.30891 47.25987 27.08694 51.48183       38.10690
## 11    29.61150 363557.63 21.63602 37.58699 17.41406 41.80895       46.93490
## 12    29.15349  43291.20 21.17801 37.12897 16.95604 41.35093       30.74010
## 13    40.73056 412041.51 32.75508 48.70604 28.53312 52.92801       48.08540
## 14    27.14545   4749.04 19.16997 35.12093 14.94800 39.34289       19.16316
## 15    28.55654    923.36 20.58106 36.53202 16.35910 40.75399       13.02265

Gráfica de pronóstico.

Residuales

checkresiduals(residuales_df$Residuales, col = "darkgreen")

## 
##  Ljung-Box test
## 
## data:  Residuals
## Q* = 21.15, df = 10, p-value = 0.02007
## 
## Model df: 0.   Total lags used: 10
# p-value = 0.02007

Exactitud

accuracy(prediccion$pronosticos, prediccion$actuales_trans)
##                ME     RMSE      MAE       MPE     MAPE
## Test set 1.272128 10.38545 9.238408 -10.24416 34.42067

Inverso de Boxcox

valores_reales <- InvBoxCox(x = prediccion, lambda = 0.1723989)
valores_reales$actuales <- NULL
valores_reales
##    pronosticos       inf       sup   inferior  superior actuales_trans
## 1     11256.88  1738.644  46137.52   472.6902  86426.23        2925.52
## 2     54675.03 13966.260 164916.40  5806.2478 274406.14        2466.16
## 3     44708.87 10813.932 139712.23  4307.0018 235774.88      204571.37
## 4     59767.27 15628.407 177532.43  6616.3549 293584.35      278469.60
## 5     11824.77  1860.622  47954.53   514.4975  89475.80       82223.67
## 6    111197.01 33822.686 298376.85 16053.2873 473412.82       40008.40
## 7    219896.62 77298.854 533077.13 40736.3810 810684.19       97084.26
## 8    218248.08 76605.327 529645.02 40328.3966 805827.76      418748.40
## 9     80649.96 22742.632 227834.29 10200.4562 369190.28      380503.13
## 10   146462.40 47349.056 376746.60 23499.1609 587379.16      125620.09
## 11    36088.33  8213.854 117233.57  3116.1080 200899.36      363557.63
## 12    33463.55  7449.696 110234.54  2775.9656 189944.42       43291.20
## 13   175898.61 59104.204 440341.61 30162.0236 678778.14      412041.51
## 14    23742.68  4756.555  83491.04  1624.4292 147568.28        4749.04
## 15    30281.58  6542.933 101634.85  2379.3065 176412.86         923.36

Gráfica de los valores